home *** CD-ROM | disk | FTP | other *** search
/ Games of Daze / Infomagic - Games of Daze (Summer 1995) (Disc 1 of 2).iso / x2ftp / msdos / source / gfxfx / 3dholesh.pas < prev    next >
Pascal/Delphi Source File  |  1994-06-22  |  7KB  |  255 lines
  1.  
  2. {$r-}
  3. program polygoned_and_shaded_hexagon;
  4. uses
  5.   crt;
  6. const
  7.   border=false;
  8.   vidseg:word=$a000;
  9.   divd=128;
  10.   dist=200;
  11.   point:array[0..11,0..2] of integer=(
  12.     (-20,-20, 30),( 20,-20, 30),( 40,-40,  0),( 20,-20,-30),
  13.     (-20,-20,-30),(-40,-40,  0),(-20, 20, 30),( 20, 20, 30),
  14.     ( 40, 40,  0),( 20, 20,-30),(-20, 20,-30),(-40, 40,  0));
  15.   planes:array[0..7,0..3] of byte=(
  16.     (1,2,8,7),(9,8,2,3),(10,4,5,11),(6,11,5,0),
  17.     (0,1,2,5),(5,2,3,4),(6,7,8,11),(11,8,9,10));
  18. var
  19.   stab:array[0..255] of integer;
  20.   polyz:array[0..7] of integer;
  21.   pind:array[0..7] of byte;
  22.   page,virscr:pointer;
  23.   pageseg,virseg:word;
  24.  
  25. { -------------------------------------------------------------------------- }
  26.  
  27. procedure setborder(col:byte); assembler;
  28. asm
  29.   xor ch,ch
  30.   mov cl,border
  31.   jcxz @out
  32.   mov dx,3dah
  33.   in al,dx
  34.   mov dx,3c0h
  35.   mov al,11h+32
  36.   out dx,al
  37.   mov al,col
  38.   out dx,al
  39.  @out:
  40. end;
  41.  
  42. { -------------------------------------------------------------------------- }
  43.  
  44. procedure retrace; assembler;
  45. asm
  46.   mov dx,3dah
  47.  @vert1:
  48.   in al,dx
  49.   test al,8
  50.   jz @vert1
  51.  @vert2:
  52.   in al,dx
  53.   test al,8
  54.   jnz @vert2
  55. end;
  56.  
  57. { -------------------------------------------------------------------------- }
  58.  
  59. procedure setpal(c,r,g,b:byte); assembler;
  60. asm
  61.   mov dx,3c8h
  62.   mov al,[c]
  63.   out dx,al
  64.   inc dx
  65.   mov al,[r]
  66.   out dx,al
  67.   mov al,[g]
  68.   out dx,al
  69.   mov al,[b]
  70.   out dx,al
  71. end;
  72.  
  73. { -------------------------------------------------------------------------- }
  74.  
  75. procedure flip(src,dst:word); assembler;
  76. asm
  77.   push ds
  78.   mov es,[dst]
  79.   mov ds,[src]
  80.   xor si,si
  81.   xor di,di
  82.   mov cx,320*200/2
  83.   rep movsw
  84.   pop ds
  85. end;
  86.  
  87. { -------------------------------------------------------------------------- }
  88.  
  89. procedure horline(xb,xe,y:integer; c:byte; where:word); assembler;
  90. asm
  91.   mov bx,[xb]
  92.   cmp bx,0              { if zero don't draw }
  93.   jz @out
  94.   mov cx,[xe]
  95.   jcxz @out
  96.   cmp bx,cx             { see if x-end is smaller than x-begin }
  97.   jb @skip
  98.   xchg bx,cx            { yes: switch coords }
  99.  @skip:
  100.   dec bx                { atatch planes }
  101.   inc cx
  102.   sub cx,bx             { length of line in cx }
  103.   mov es,[where]        { segment to draw in }
  104.   mov ax,[y]            { heigth of line }
  105.   shl ax,6
  106.   mov di,ax
  107.   shl ax,2
  108.   add di,ax             { y*320 in di (offset) }
  109.   add di,bx             { add x-begin }
  110.   mov al,[c]            { get color }
  111.   shr cx,1              { div length by 2 }
  112.   jnc @skip2            { carry set? }
  113.   stosb                 { draw byte }
  114.  @skip2:
  115.   mov ah,al             { copy color in hi-byte }
  116.   rep stosw             { draw (rest of) line }
  117.  @out:
  118. end;
  119.  
  120. procedure polygon(x1,y1,x2,y2,x3,y3,x4,y4:integer; c:byte);
  121. var
  122.   xpos:array[0..199,0..1] of integer;
  123.   mny,mxy,y:integer;
  124.   i:word;
  125.   s1,s2,s3,s4:shortint;
  126. begin
  127.   mny:=y1;
  128.   if y2<mny then mny:=y2;
  129.   if y3<mny then mny:=y3;
  130.   if y4<mny then mny:=y4;
  131.   mxy:=y1;
  132.   if y2>mxy then mxy:=y2;
  133.   if y3>mxy then mxy:=y3;
  134.   if y4>mxy then mxy:=y4;
  135.   s1:=byte(y1<y2)*2-1;
  136.   s2:=byte(y2<y3)*2-1;
  137.   s3:=byte(y3<y4)*2-1;
  138.   s4:=byte(y4<y1)*2-1;
  139.   y:=y1;
  140.   if y1<>y2 then repeat
  141.     xpos[y,byte(y1<y2)]:=integer(x2-x1)*(y-y1) div (y2-y1)+x1;
  142.     inc(y,s1);
  143.   until y=y2+s1 else xpos[y,byte(y1<y2)]:=x1;
  144.   y:=y2;
  145.   if y2<>y3 then repeat
  146.     xpos[y,byte(y2<y3)]:=integer(x3-x2)*(y-y2) div (y3-y2)+x2;
  147.     inc(y,s2);
  148.   until y=y3+s2 else xpos[y,byte(y2<y3)]:=x2;
  149.   y:=y3;
  150.   if y3<>y4 then repeat
  151.     xpos[y,byte(y3<y4)]:=integer(x4-x3)*(y-y3) div (y4-y3)+x3;
  152.     inc(y,s3);
  153.   until y=y4+s3 else xpos[y,byte(y3<y4)]:=x3;
  154.   y:=y4;
  155.   if y4<>y1 then repeat
  156.     xpos[y,byte(y4<y1)]:=integer(x1-x4)*(y-y4) div (y1-y4)+x4;
  157.     inc(y,s4);
  158.   until y=y1+s4 else xpos[y,byte(y1<y4)]:=x4;
  159.   for y:=mny to mxy do
  160.     horline(xpos[y,0],xpos[y,1],y,c,virseg);
  161. end;
  162.  
  163. { -------------------------------------------------------------------------- }
  164.  
  165. procedure quicksort(lo,hi:integer);
  166.  
  167. procedure sort(l,r:integer);
  168. var i,j,x,y:integer;
  169. begin
  170.   i:=l; j:=r; x:=polyz[(l+r) div 2];
  171.   repeat
  172.     while polyz[i]<x do inc(i);
  173.     while x<polyz[j] do dec(j);
  174.     if i<=j then begin
  175.       y:=polyz[i]; polyz[i]:=polyz[j]; polyz[j]:=y;
  176.       y:=pind[i]; pind[i]:=pind[j]; pind[j]:=y;
  177.       inc(i); dec(j);
  178.     end;
  179.   until i>j;
  180.   if l<j then sort(l,j);
  181.   if i<r then sort(i,r);
  182. end;
  183.  
  184. begin
  185.   sort(lo,hi);
  186. end;
  187.  
  188. { -------------------------------------------------------------------------- }
  189.  
  190. function sinus(i:byte):integer; begin sinus:=stab[i]; end;
  191. function cosinus(i:byte):integer; begin cosinus:=stab[(i+192) mod 255]; end;
  192.  
  193. { -------------------------------------------------------------------------- }
  194.  
  195. procedure rotate_cube;
  196. const xst=2; yst=3; zst=-4;
  197. var
  198.   xp,yp,z:array[0..11] of integer;
  199.   x,y,i,j,k:integer;
  200.   n,Key,phix,phiy,phiz:byte;
  201. begin
  202.   phix:=0; phiy:=0; phiz:=40;
  203.   fillchar(xp,sizeof(xp),0);
  204.   fillchar(yp,sizeof(yp),0);
  205.   repeat
  206.     {retrace;}
  207.     setborder(10);
  208.     flip(pageseg,virseg);
  209.     for n:=0 to 11 do begin
  210.       i:=(cosinus(phiy)*point[n,0]-sinus(phiy)*point[n,2]) div divd;
  211.       j:=(cosinus(phiz)*point[n,1]-sinus(phiz)*i) div divd;
  212.       k:=(cosinus(phiy)*point[n,2]+sinus(phiy)*point[n,0]) div divd;
  213.       x:=(cosinus(phiz)*i+sinus(phiz)*point[n,1]) div divd;
  214.       y:=(cosinus(phix)*j+sinus(phix)*k) div divd;
  215.       z[n]:=(cosinus(phix)*k-sinus(phix)*j) div divd+cosinus(phix) div 3;
  216.       xp[n]:=160+sinus(phix) div 2+(-x*dist) div (z[n]-dist);
  217.       yp[n]:=100+(-y*dist) div (z[n]-dist);
  218.     end;
  219.     for n:=0 to 7 do begin
  220.       polyz[n]:=(z[planes[n,0]]+z[planes[n,1]]+z[planes[n,2]]+z[planes[n,3]]) div 4;
  221.       pind[n]:=n;
  222.     end;
  223.     quicksort(0,7);
  224.     for n:=0 to 7 do
  225.       polygon(xp[planes[pind[n],0]],yp[planes[pind[n],0]],
  226.               xp[planes[pind[n],1]],yp[planes[pind[n],1]],
  227.               xp[planes[pind[n],2]],yp[planes[pind[n],2]],
  228.               xp[planes[pind[n],3]],yp[planes[pind[n],3]],polyz[n]+75);
  229.     inc(phix,xst); inc(phiy,yst); inc(phiz,zst);
  230.     setborder(0);
  231.     flip(virseg,vidseg);
  232.   until keypressed;
  233. end;
  234.  
  235. { -------------------------------------------------------------------------- }
  236.  
  237. var i,j:word;
  238. begin
  239.   asm mov ax,13h; int 10h; end;
  240.   getmem(virscr,64000);
  241.   virseg:=seg(virscr^);
  242.   getmem(page,64000);
  243.   pageseg:=seg(page^);
  244.   for i:=0 to 255 do stab[i]:=round(sin(i*pi/128)*divd);
  245.   for i:=1 to 150 do setpal(i,30+i div 6,20+i div 7,10+i div 7);
  246.   for i:=1 to 104 do setpal(150+i,0,20+i div 4,30+i div 5);
  247.   for i:=0 to 319 do for j:=0 to 199 do mem[pageseg:j*320+i]:=151+(i*i+j*j) mod 104;
  248.   rotate_cube;
  249.   freemem(page,64000);
  250.   freemem(virscr,64000);
  251.   textmode(lastmode);
  252. end.
  253.  
  254. { 3d-stuff inc. background }
  255.